{-
 This file is part of the Clafer to Alloy Translator (clafer2alloy).

 Copyright (C) 2010 Kacper Bak <http://gsd.uwaterloo.ca/kbak>

 clafer2alloy is free software: you can redistribute it and/or modify
 it under the terms of the GNU Lesser General Public License as published by
 the Free Software Foundation, either version 3 of the License, or
 (at your option) any later version.

 clafer2alloy is distributed in the hope that it will be useful,
 but WITHOUT ANY WARRANTY; without even the implied warranty of
 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 GNU Lesser General Public License for more details.

 You should have received a copy of the GNU Lesser General Public License
 along with clafer2alloy. (See files COPYING and COPYING.LESSER.)  If not,
 see <http://www.gnu.org/licenses/>.
-}
{-# OPTIONS -fno-warn-incomplete-patterns #-}
module Printclafer2alloy where

-- pretty-printer generated by the BNF converter

import Absclafer2alloy
import Char

-- the top-level printing method
printTree :: Print a => a -> String
printTree = render . prt 0

type Doc = [ShowS] -> [ShowS]

doc :: ShowS -> Doc
doc = (:)

render :: Doc -> String
render d = rend 0 (map ($ "") $ d []) "" where
  rend i ss = case ss of
    "["      :ts -> showChar '[' . rend i ts
    "("      :ts -> showChar '(' . rend i ts
    "{"      :ts -> showChar '{' . new (i+1) . rend (i+1) ts
    "}" : ";":ts -> new (i-1) . space "}" . showChar ';' . new (i-1) . rend (i-1) ts
    "}"      :ts -> new (i-1) . showChar '}' . new (i-1) . rend (i-1) ts
    ";"      :ts -> showChar ';' . new i . rend i ts
    t  : "," :ts -> showString t . space "," . rend i ts
    t  : ")" :ts -> showString t . showChar ')' . rend i ts
    t  : "]" :ts -> showString t . showChar ']' . rend i ts
    t        :ts -> space t . rend i ts
    _            -> id
  new i   = showChar '\n' . replicateS (2*i) (showChar ' ') . dropWhile isSpace
  space t = showString t . (\s -> if null s then "" else (' ':s))

parenth :: Doc -> Doc
parenth ss = doc (showChar '(') . ss . doc (showChar ')')

concatS :: [ShowS] -> ShowS
concatS = foldr (.) id

concatD :: [Doc] -> Doc
concatD = foldr (.) id

replicateS :: Int -> ShowS -> ShowS
replicateS n f = concatS (replicate n f)

-- the printer class does the job
class Print a where
  prt :: Int -> a -> Doc
  prtList :: [a] -> Doc
  prtList = concatD . map (prt 0)

instance Print a => Print [a] where
  prt _ = prtList

instance Print Char where
  prt _ s = doc (showChar '\'' . mkEsc '\'' s . showChar '\'')
  prtList s = doc (showChar '"' . concatS (map (mkEsc '"') s) . showChar '"')

mkEsc :: Char -> Char -> ShowS
mkEsc q s = case s of
  _ | s == q -> showChar '\\' . showChar s
  '\\'-> showString "\\\\"
  '\n' -> showString "\\n"
  '\t' -> showString "\\t"
  _ -> showChar s

prPrec :: Int -> Int -> Doc -> Doc
prPrec i j = if j<i then parenth else id


instance Print Integer where
  prt _ x = doc (shows x)


instance Print Double where
  prt _ x = doc (shows x)


instance Print Ident where
  prt _ (Ident i) = doc (showString i)



instance Print Module where
  prt i e = case e of
   Module declarations -> prPrec i 0 (concatD [prt 0 declarations])


instance Print Declaration where
  prt i e = case e of
   EnumDecl id enumids -> prPrec i 0 (concatD [doc (showString "enum") , prt 0 id , doc (showString "=") , prt 0 enumids])
   AbsClaferDecl gcard id super attr elements -> prPrec i 0 (concatD [doc (showString "abstract") , prt 0 gcard , prt 0 id , prt 0 super , prt 0 attr , prt 0 elements])
   ClaferDecl clafer -> prPrec i 0 (concatD [prt 0 clafer])
   ConstDecl constraint -> prPrec i 0 (concatD [prt 0 constraint])

  prtList es = case es of
   [] -> (concatD [])
   x:xs -> (concatD [prt 0 x , prt 0 xs])

instance Print Clafer where
  prt i e = case e of
   Clafer gcard id super attr essential card elements -> prPrec i 0 (concatD [prt 0 gcard , prt 0 id , prt 0 super , prt 0 attr , prt 0 essential , prt 0 card , prt 0 elements])


instance Print Constraint where
  prt i e = case e of
   Constraint essential lexps -> prPrec i 0 (concatD [prt 0 essential , doc (showString "[") , prt 0 lexps , doc (showString "]")])


instance Print Elements where
  prt i e = case e of
   ElementsEmpty  -> prPrec i 0 (concatD [])
   Elements elements -> prPrec i 0 (concatD [doc (showString "{") , prt 0 elements , doc (showString "}")])


instance Print Element where
  prt i e = case e of
   Subclafer clafer -> prPrec i 0 (concatD [prt 0 clafer])
   ClaferUse name essential card elements -> prPrec i 0 (concatD [doc (showString "`") , prt 0 name , prt 0 essential , prt 0 card , prt 0 elements])
   Subconstraint constraint -> prPrec i 0 (concatD [prt 0 constraint])

  prtList es = case es of
   [] -> (concatD [])
   x:xs -> (concatD [prt 0 x , prt 0 xs])

instance Print Essential where
  prt i e = case e of
   EssentialEmpty  -> prPrec i 0 (concatD [])
   Essential  -> prPrec i 0 (concatD [doc (showString "!")])


instance Print Super where
  prt i e = case e of
   SuperEmpty  -> prPrec i 0 (concatD [])
   SuperColon name -> prPrec i 0 (concatD [doc (showString ":") , prt 0 name])
   Super name -> prPrec i 0 (concatD [doc (showString "extends") , prt 0 name])


instance Print Attr where
  prt i e = case e of
   AttrEmpty  -> prPrec i 0 (concatD [])
   AttrSuper modids sexp -> prPrec i 0 (concatD [doc (showString ":") , prt 0 modids , prt 0 sexp])
   AttrSExp modids sexp -> prPrec i 0 (concatD [doc (showString ":") , prt 0 modids , prt 0 sexp])
   Attr modids nav -> prPrec i 0 (concatD [doc (showString "->") , prt 0 modids , prt 0 nav])


instance Print GCard where
  prt i e = case e of
   GCardEmpty  -> prPrec i 0 (concatD [])
   GCardXor  -> prPrec i 0 (concatD [doc (showString "xor")])
   GCardOr  -> prPrec i 0 (concatD [doc (showString "or")])
   GCardMux  -> prPrec i 0 (concatD [doc (showString "mux")])
   GCardOpt  -> prPrec i 0 (concatD [doc (showString "opt")])
   GCardInterval gncard -> prPrec i 0 (concatD [doc (showString "<") , prt 0 gncard , doc (showString ">")])


instance Print Card where
  prt i e = case e of
   CardEmpty  -> prPrec i 0 (concatD [])
   CardLone  -> prPrec i 0 (concatD [doc (showString "?")])
   CardSome  -> prPrec i 0 (concatD [doc (showString "+")])
   CardAny  -> prPrec i 0 (concatD [doc (showString "*")])
   CardInterval ncard -> prPrec i 0 (concatD [prt 0 ncard])


instance Print GNCard where
  prt i e = case e of
   GNCard n exinteger -> prPrec i 0 (concatD [prt 0 n , doc (showString "-") , prt 0 exinteger])


instance Print NCard where
  prt i e = case e of
   NCard n exinteger -> prPrec i 0 (concatD [prt 0 n , doc (showString "..") , prt 0 exinteger])


instance Print ExInteger where
  prt i e = case e of
   ExIntegerAst  -> prPrec i 0 (concatD [doc (showString "*")])
   ExIntegerNum n -> prPrec i 0 (concatD [prt 0 n])


instance Print Nav where
  prt i e = case e of
   NavJoin nav0 nav -> prPrec i 0 (concatD [prt 0 nav0 , doc (showString ".") , prt 1 nav])
   NavArrow nav0 nav -> prPrec i 1 (concatD [prt 1 nav0 , doc (showString "@") , prt 2 nav])
   NavIdent id -> prPrec i 2 (concatD [prt 0 id])


instance Print Name where
  prt i e = case e of
   Name modids id -> prPrec i 0 (concatD [prt 0 modids , prt 0 id])


instance Print LExp where
  prt i e = case e of
   EIff lexp0 iff lexp -> prPrec i 0 (concatD [prt 0 lexp0 , prt 0 iff , prt 1 lexp])
   EImplies lexp0 implies lexp -> prPrec i 1 (concatD [prt 1 lexp0 , prt 0 implies , prt 2 lexp])
   EImpliesElse lexp0 implies lexp1 lexp -> prPrec i 1 (concatD [prt 1 lexp0 , prt 0 implies , prt 2 lexp1 , doc (showString "else") , prt 2 lexp])
   EOr lexp0 or lexp -> prPrec i 2 (concatD [prt 2 lexp0 , prt 0 or , prt 3 lexp])
   EXor lexp0 xor lexp -> prPrec i 3 (concatD [prt 3 lexp0 , prt 0 xor , prt 4 lexp])
   EAnd lexp0 and lexp -> prPrec i 4 (concatD [prt 4 lexp0 , prt 0 and , prt 5 lexp])
   ENeg neg lexp -> prPrec i 5 (concatD [prt 0 neg , prt 6 lexp])
   ETerm term -> prPrec i 6 (concatD [prt 0 term])

  prtList es = case es of
   [] -> (concatD [])
   x:xs -> (concatD [prt 0 x , prt 0 xs])

instance Print Term where
  prt i e = case e of
   TermCmpExp cmpexp -> prPrec i 0 (concatD [prt 0 cmpexp])
   TermSet sexp -> prPrec i 0 (concatD [prt 0 sexp])
   TermQuantSet quant sexp -> prPrec i 0 (concatD [prt 0 quant , prt 0 sexp])
   TermQuantDeclExp decls lexp -> prPrec i 0 (concatD [prt 0 decls , doc (showString "|") , prt 0 lexp])


instance Print Iff where
  prt i e = case e of
   Iff  -> prPrec i 0 (concatD [doc (showString "<=>")])


instance Print Implies where
  prt i e = case e of
   Implies  -> prPrec i 0 (concatD [doc (showString "=>")])


instance Print And where
  prt i e = case e of
   And  -> prPrec i 0 (concatD [doc (showString "&&")])


instance Print Xor where
  prt i e = case e of
   Xor  -> prPrec i 0 (concatD [doc (showString "xor")])


instance Print Or where
  prt i e = case e of
   Or  -> prPrec i 0 (concatD [doc (showString "||")])


instance Print Neg where
  prt i e = case e of
   Neg  -> prPrec i 0 (concatD [doc (showString "~")])


instance Print CmpExp where
  prt i e = case e of
   ELt exp0 exp -> prPrec i 0 (concatD [prt 0 exp0 , doc (showString "<") , prt 0 exp])
   EGt exp0 exp -> prPrec i 0 (concatD [prt 0 exp0 , doc (showString ">") , prt 0 exp])
   EREq exp0 exp -> prPrec i 0 (concatD [prt 0 exp0 , doc (showString "=") , prt 0 exp])
   EEq exp0 exp -> prPrec i 0 (concatD [prt 0 exp0 , doc (showString "==") , prt 0 exp])
   ELte exp0 exp -> prPrec i 0 (concatD [prt 0 exp0 , doc (showString "<=") , prt 0 exp])
   EGte exp0 exp -> prPrec i 0 (concatD [prt 0 exp0 , doc (showString ">=") , prt 0 exp])
   ENeq exp0 exp -> prPrec i 0 (concatD [prt 0 exp0 , doc (showString "!=") , prt 0 exp])
   ERNeq exp0 exp -> prPrec i 0 (concatD [prt 0 exp0 , doc (showString "/=") , prt 0 exp])
   EIn exp0 exp -> prPrec i 0 (concatD [prt 0 exp0 , doc (showString "in") , prt 0 exp])
   ENin exp0 exp -> prPrec i 0 (concatD [prt 0 exp0 , doc (showString "not") , doc (showString "in") , prt 0 exp])


instance Print Exp where
  prt i e = case e of
   ESetExp sexp -> prPrec i 0 (concatD [prt 0 sexp])
   ENumExp aexp -> prPrec i 0 (concatD [prt 0 aexp])
   EStrExp strexp -> prPrec i 0 (concatD [prt 0 strexp])


instance Print Quant where
  prt i e = case e of
   QuantNo  -> prPrec i 0 (concatD [doc (showString "no")])
   QuantLone  -> prPrec i 0 (concatD [doc (showString "lone")])
   QuantOne  -> prPrec i 0 (concatD [doc (showString "one")])
   QuantSome  -> prPrec i 0 (concatD [doc (showString "some")])


instance Print ExQuant where
  prt i e = case e of
   ExQuantAll  -> prPrec i 0 (concatD [doc (showString "all")])
   ExQuant quant -> prPrec i 0 (concatD [prt 0 quant])


instance Print SExp where
  prt i e = case e of
   SExpUnion sexp0 sexp -> prPrec i 0 (concatD [prt 0 sexp0 , doc (showString "+") , prt 1 sexp])
   SExpIntersection sexp0 sexp -> prPrec i 1 (concatD [prt 1 sexp0 , doc (showString "&") , prt 2 sexp])
   SExpDomain sexp0 sexp -> prPrec i 2 (concatD [prt 2 sexp0 , doc (showString "<:") , prt 3 sexp])
   SExpRange sexp0 sexp -> prPrec i 3 (concatD [prt 3 sexp0 , doc (showString ":>") , prt 4 sexp])
   SExpJoin sexp0 sexp -> prPrec i 4 (concatD [prt 4 sexp0 , doc (showString ".") , prt 5 sexp])
   SExpRIdent id _ -> prPrec i 6 (concatD [prt 0 id])
   SExpArrow sexp0 sexp -> prPrec i 5 (concatD [prt 5 sexp0 , doc (showString "@") , prt 6 sexp])
   SExpIdent id -> prPrec i 6 (concatD [prt 0 id])


instance Print Decl where
  prt i e = case e of
   Decl exquant disj locids sexp -> prPrec i 0 (concatD [prt 0 exquant , prt 0 disj , prt 0 locids , doc (showString ":") , prt 0 sexp])

  prtList es = case es of
   [x] -> (concatD [prt 0 x])
   x:xs -> (concatD [prt 0 x , doc (showString ",") , prt 0 xs])

instance Print Disj where
  prt i e = case e of
   DisjEmpty  -> prPrec i 0 (concatD [])
   Disj  -> prPrec i 0 (concatD [doc (showString "disj")])


instance Print AExp where
  prt i e = case e of
   EAdd aexp0 aexp -> prPrec i 0 (concatD [prt 0 aexp0 , doc (showString "+") , prt 1 aexp])
   ESub aexp0 aexp -> prPrec i 1 (concatD [prt 1 aexp0 , doc (showString "-") , prt 2 aexp])
   EMul aexp0 aexp -> prPrec i 2 (concatD [prt 2 aexp0 , doc (showString "*") , prt 3 aexp])
   EUmn aexp -> prPrec i 3 (concatD [doc (showString "-") , prt 4 aexp])
   ECSetExp sexp -> prPrec i 4 (concatD [doc (showString "#") , prt 0 sexp])
   EInt n -> prPrec i 4 (concatD [prt 0 n])


instance Print StrExp where
  prt i e = case e of
   EConc strexp0 strexp -> prPrec i 0 (concatD [prt 0 strexp0 , doc (showString "++") , prt 0 strexp])
   EStr str -> prPrec i 0 (concatD [prt 0 str])


instance Print EnumId where
  prt i e = case e of
   EnumIdIdent id -> prPrec i 0 (concatD [prt 0 id])

  prtList es = case es of
   [x] -> (concatD [prt 0 x])
   x:xs -> (concatD [prt 0 x , doc (showString "|") , prt 0 xs])

instance Print ModId where
  prt i e = case e of
   ModIdIdent id -> prPrec i 0 (concatD [prt 0 id])

  prtList es = case es of
   [] -> (concatD [])
   x:xs -> (concatD [prt 0 x , doc (showString "/") , prt 0 xs])

instance Print LocId where
  prt i e = case e of
   LocIdIdent id -> prPrec i 0 (concatD [prt 0 id])

  prtList es = case es of
   [x] -> (concatD [prt 0 x])
   x:xs -> (concatD [prt 0 x , doc (showString ",") , prt 0 xs])


